Bank Marketing Data Analysis

Input variables:

Output variable (Target):

21 - y - has the client subscribed a term deposit? (binary: 'yes','no')

Import Libraries

You can unfold the code if you want to check what libraries are used

suppressPackageStartupMessages({
library(tidyverse)
library(rapportools)
library(data.table) # datafile reading
library(dplyr)
library(dlookr)
library(magrittr)
library(tidyr)
library(lubridate)
library(DT)
library(gmodels)
library(sqldf)
library(caret)      # rocr analysis
library(ROCR)       # rocr analysis
library(kableExtra) # nice table html formating 
library(gridExtra)  # arranging ggplot in grid
library(rpart)      # decision tree
library(rpart.plot) # decision tree plotting
library(caTools)    # split 
library(randomForest) #randomforests
library(class) # knn
library(ipred) # bagging
library(adabag) # boosting
library(purrr)
library(fastDummies)
library(DMwR)
  
#visualization
library(ggplot2)
library(ggmosaic)
library(corrplot)
library(ggthemes)
library(sqldf)
library(readr)
library(plotly)
library(cowplot)
library(plotROC)
library(ggpubr)
    
library(C50)
library(e1071)
library(pROC)
library(PRROC)
    
library(rattle)
library(RColorBrewer)
    
library(forecast)
library(zoo)
library(DescTools)
library(knitr)
library(VIM)
library(mice)
library(psych)
library(gmodels)
library(caTools)
library(Epi)
library(tidyverse)
})

Load Dataset

bank <- read.csv(file = "/Users/jiyoungkim/Desktop/SGH 2 sem/SLM class/Project/bank-additional/bank-additional-full.csv", 
                 sep =";", stringsAsFactors = T)
str(bank)

'data.frame':   41188 obs. of  21 variables:
 $ age           : int  56 57 37 40 56 45 59 41 24 25 ...
 $ job           : Factor w/ 12 levels "admin.","blue-collar",..: 4 8 8 1 8 8 1 2 10 8 ...
 $ marital       : Factor w/ 4 levels "divorced","married",..: 2 2 2 2 2 2 2 2 3 3 ...
 $ education     : Factor w/ 8 levels "basic.4y","basic.6y",..: 1 4 4 2 4 3 6 8 6 4 ...
 $ default       : Factor w/ 3 levels "no","unknown",..: 1 2 1 1 1 2 1 2 1 1 ...
 $ housing       : Factor w/ 3 levels "no","unknown",..: 1 1 3 1 1 1 1 1 3 3 ...
 $ loan          : Factor w/ 3 levels "no","unknown",..: 1 1 1 1 3 1 1 1 1 1 ...
 $ contact       : Factor w/ 2 levels "cellular","telephone": 2 2 2 2 2 2 2 2 2 2 ...
 $ month         : Factor w/ 10 levels "apr","aug","dec",..: 7 7 7 7 7 7 7 7 7 7 ...
 $ day_of_week   : Factor w/ 5 levels "fri","mon","thu",..: 2 2 2 2 2 2 2 2 2 2 ...
 $ duration      : int  261 149 226 151 307 198 139 217 380 50 ...
 $ campaign      : int  1 1 1 1 1 1 1 1 1 1 ...
 $ pdays         : int  999 999 999 999 999 999 999 999 999 999 ...
 $ previous      : int  0 0 0 0 0 0 0 0 0 0 ...
 $ poutcome      : Factor w/ 3 levels "failure","nonexistent",..: 2 2 2 2 2 2 2 2 2 2 ...
 $ emp.var.rate  : num  1.1 1.1 1.1 1.1 1.1 1.1 1.1 1.1 1.1 1.1 ...
 $ cons.price.idx: num  94 94 94 94 94 ...
 $ cons.conf.idx : num  -36.4 -36.4 -36.4 -36.4 -36.4 -36.4 -36.4 -36.4 -36.4 -36.4 ...
 $ euribor3m     : num  4.86 4.86 4.86 4.86 4.86 ...
 $ nr.employed   : num  5191 5191 5191 5191 5191 ...
 $ y             : Factor w/ 2 levels "no","yes": 1 1 1 1 1 1 1 1 1 1 ...

summary(bank)

      age                 job            marital     
 Min.   :17.00   admin.     :10422   divorced: 4612  
 1st Qu.:32.00   blue-collar: 9254   married :24928  
 Median :38.00   technician : 6743   single  :11568  
               education        default         housing           loan      
 university.degree  :12168   no     :32588   no     :18622   no     :33950  
 high.school        : 9515   unknown: 8597   unknown:  990   unknown:  990  
 basic.9y           : 6045   yes    :    3   yes    :21576   yes    : 6248  
      contact          month       day_of_week    duration     
 cellular :26144   may    :13769   fri:7827    Min.   :   0.0  
 telephone:15044   jul    : 7174   mon:8514    1st Qu.: 102.0  
                   aug    : 6178   thu:8623    Median : 180.0  
    campaign          pdays          previous            poutcome    
 Min.   : 1.000   Min.   :  0.0   Min.   :0.000   failure    : 4252  
 1st Qu.: 1.000   1st Qu.:999.0   1st Qu.:0.000   nonexistent:35563  
 Median : 2.000   Median :999.0   Median :0.000   success    : 1373  
  emp.var.rate      cons.price.idx  cons.conf.idx     euribor3m    
 Min.   :-3.40000   Min.   :92.20   Min.   :-50.8   Min.   :0.634  
 1st Qu.:-1.80000   1st Qu.:93.08   1st Qu.:-42.7   1st Qu.:1.344  
 Median : 1.10000   Median :93.75   Median :-41.8   Median :4.857  
  nr.employed     y        
 Min.   :4964   no :36548  
 1st Qu.:5099   yes: 4640  
 Median :5191              
 [ reached getOption("max.print") -- omitted 4 rows ]

Target Variable

We can see that our data is highly imbalanced like Yes:No = 11%:89% which means that we have too small proportion of 'Yes' to use this data for modelling. Therefore, after EDA part, as we prepare our dataset for modelling, we will use SMOTE (Synthetic Minority Over-Sampling Technique) to deal with this Imabalanced data issue.

ggplot(data = bank_final, aes(x=y, label = scales::percent(prop.table(stat(count)))))+
  geom_bar(stat = "count", aes(fill=y))+
  geom_text(stat = 'count', position = position_dodge(.9), vjust = -0.5, size = 3.5) +
  scale_y_continuous(labels = scales::percent) +
  stat_count(geom = "text", colour = "black", size = 3.5, aes(label = ..count..),position=position_stack(vjust=0.5))+
  labs(title="Distribution of y variable (Deposit)", x="Deposit", y="Count") + scale_fill_brewer(palette="Set3")

Categorical Variables

Just as an overview, let's start with checking the levels with the biggest proportion within each categorical variables.

diagnose_category(bank_final) %>%
  filter(rank == 1)

# A tibble: 12 x 6
   variables   levels                N  freq ratio  rank
   <chr>       <fct>             <int> <int> <dbl> <int>
 1 job         admin.            40307 10172  25.2     1
 2 marital     married           40307 24386  60.5     1
 3 education   university.degree 40307 11904  29.5     1
 4 default     no                40307 31943  79.2     1
 5 housing     yes               40307 21149  52.5     1
 6 loan        no                40307 33217  82.4     1
 7 contact     cellular          40307 25732  63.8     1
 8 month       may               40307 13592  33.7     1
 9 day_of_week thu               40307  8389  20.8     1
10 previous    0                 40307 34691  86.1     1
11 poutcome    nonexistent       40307 34691  86.1     1
12 y           no                40307 35695  88.6     1

Based on the result, we can glimpse what kind of attributes are represented by our clients pool. For example, we can see a large portion of clients who have admin jobs, married, university degree, no credit in default, housing loan, no personal loan, had cellularphone for contact, last contact in May, last contact in thursday, and had no previous contact before this campaign

1) Job

job_y <- sqldf(
"select job, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select job, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

job_y

             job total deposit_yes deposit_no yes_ratio no_ratio
1        student   868         275        593     31.68    68.32
2        retired  1684         432       1252     25.65    74.35
3     unemployed   990         144        846     14.55    85.45
4         admin. 10172        1342       8830     13.19    86.81
5     management  2868         328       2540     11.44    88.56
6        unknown   321          36        285     11.21    88.79
7     technician  6611         728       5883     11.01    88.99
8  self-employed  1389         148       1241     10.66    89.34
9      housemaid  1032         106        926     10.27    89.73
10  entrepreneur  1424         124       1300      8.71    91.29
11      services  3886         322       3564      8.29    91.71
12   blue-collar  9062         627       8435      6.92    93.08

In the table above, you can see the 'unknown' level (which is regarded as kind of 'missing value') shows nothing unique or insightful in here. They have similar distribution like other levels and nothing special, so it will not hurt our dataset very much by dropping this unknown values in 'job' variable. Let's drop it.

bank_final = bank_final %>% filter(job != "unknown")
bank_final$job <- factor(bank_final$job)

Below plot is the overall distribution of variable 'job' after dropping those 330 unknown values. (visualized plot and data table)

# Set up default parameters for mosaic plots
mosaic_theme = theme(axis.text.x = element_text(angle = 90,
                                                hjust = 1,
                                                vjust = 0.5),
                     axis.text.y = element_blank(),
                     axis.ticks.y = element_blank())

job_vis <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, job), fill = y)) + mosaic_theme +
  xlab("job") + scale_fill_brewer(palette="Set2")

ggplotly(job_vis)

job_y_new <- sqldf(
"select job, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select job, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

job_y_new

             job total deposit_yes deposit_no yes_ratio no_ratio
1        student   868         275        593     31.68    68.32
2        retired  1684         432       1252     25.65    74.35
3     unemployed   990         144        846     14.55    85.45
4         admin. 10172        1342       8830     13.19    86.81
5     management  2868         328       2540     11.44    88.56
6     technician  6611         728       5883     11.01    88.99
7  self-employed  1389         148       1241     10.66    89.34
8      housemaid  1032         106        926     10.27    89.73
9   entrepreneur  1424         124       1300      8.71    91.29
10      services  3886         322       3564      8.29    91.71
11   blue-collar  9062         627       8435      6.92    93.08

Insights from 'Job' variable
- As we can see above, clients who are student(31.7%) or retired(25.7%) had subscribed the 'Deposit (yes)' relatively more than clients with other jobs.
- Since we have high positive deposit subscription ratio from retired clients, it might be also good idea to think of creating another cross-selling product (it can be loan, fund, etc...) customized to retired clients.
- One of our hypothesis that we set at the beginning, "Client with ceratin type of 'job' has more chance to subscribe a term deposit than the other." turns out to be true. And the result shows the clients who are student or retired or unemployed are more likely to subscribe the Deposit.

2) Marital

marital_y <- sqldf(
"select marital, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select marital, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

marital_y

   marital total deposit_yes deposit_no yes_ratio no_ratio
1   single 11254        1596       9658     14.18    85.82
2  unknown    68           9         59     13.24    86.76
3 divorced  4506         471       4035     10.45    89.55
4  married 24158        2500      21658     10.35    89.65

Also in the 'marital' variable, 'unknown' level doesn't give any special insights and it's really small portion as 68 obs. So, it doesn't harm our data distribution even if we delete it.

marital_v <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, marital), fill = y)) + mosaic_theme +
  xlab("marital status") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set2")

ggplotly(marital_v)

marital_y_new <- sqldf(
"select marital, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select marital, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

marital_y_new

   marital total deposit_yes deposit_no yes_ratio no_ratio
1   single 11254        1596       9658     14.18    85.82
2 divorced  4506         471       4035     10.45    89.55
3  married 24158        2500      21658     10.35    89.65

Insights from 'Marital' variable
As you can see, there is no severe difference in Deposit subscription ratio between single(14.18%), divorced(10.45%), married(10.35%) clients. Single clients are only slightly more subscribing Deposit.

3) Education

education_y <- sqldf(
"select education, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select education, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

education_y

            education total deposit_yes deposit_no yes_ratio no_ratio
1          illiterate    18           4         14     22.22    77.78
2             unknown  1556         231       1325     14.85    85.15
3   university.degree 11832        1645      10187     13.90    86.10
4 professional.course  5118         591       4527     11.55    88.45
5         high.school  9249        1024       8225     11.07    88.93
6            basic.4y  4028         420       3608     10.43    89.57
7            basic.6y  2225         187       2038      8.40    91.60
8            basic.9y  5892         465       5427      7.89    92.11

There are two things we need to preprocess based on above table result.
1) Need to drop 'illiterate' variable which has risk of giving wrong influence on our modelling with extremely small obs. I will drop it.
2) Different from previous categorical variables, 'Education' variable actually has quite large amount of 'unknown' level(1556) and Deposit (yes) ratio within it is also quite high comparing to other level. Therefore, we will integrate this unknown level into the university.degree which has 3rd highest Deposit(yes)_ratio right below unknown and has very similar distribution of y with unknown level.

# Drop 'illiterate' level
bank_final = bank_final %>% filter(education != "illiterate")
# Integrate 'unknown' level into 'university.degree' level
bank_final = bank_final %>% 
  dplyr::mutate(education = recode(education, "unknown" = "university.degree"))

bank_final$education <- factor(bank_final$education)

After preprocessing those 2 points, the distribution looks like below.

education_y_new <- sqldf(
"select education, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select education, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

education_y_new

            education total deposit_yes deposit_no yes_ratio no_ratio
1   university.degree 13388        1876      11512     14.01    85.99
2 professional.course  5118         591       4527     11.55    88.45
3         high.school  9249        1024       8225     11.07    88.93
4            basic.4y  4028         420       3608     10.43    89.57
5            basic.6y  2225         187       2038      8.40    91.60
6            basic.9y  5892         465       5427      7.89    92.11

education_vis<- ggplot(education_y_new, aes(education, yes_ratio)) +
  geom_point(aes(color = education, size = total)) +
  theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  labs(title = "Deposit(yes) ratio by Education",
        x = "Education", y = "Deposit(yes) ratio(%)") + theme(text = element_text(face = "bold")) +
  scale_colour_brewer()

ggplotly(education_vis)

4) Default

# setting default parameters for crosstables
crosstable_function = function(df, var1, var2){
  # df: dataframe containing both columns to cross
  # var1, var2: columns to cross together.
  CrossTable(df[, var1], df[, var2],
             prop.r = T,
             prop.c = F,
             prop.t = F,
             prop.chisq = F,
             dnn = c(var1, var2))
}


crosstable_function(bank_final, "default", "y")

 
   Cell Contents
|-------------------------|
|                       N |
|           N / Row Total |
|-------------------------|

 
Total Observations in Table:  39900 

 
             | y 
     default |        no |       yes | Row Total | 
-------------|-----------|-----------|-----------|
          no |     27564 |      4134 |     31698 | 
             |     0.870 |     0.130 |     0.794 | 
-------------|-----------|-----------|-----------|
     unknown |      7770 |       429 |      8199 | 
             |     0.948 |     0.052 |     0.205 | 
-------------|-----------|-----------|-----------|
         yes |         3 |         0 |         3 | 
             |     1.000 |     0.000 |     0.000 | 
-------------|-----------|-----------|-----------|
Column Total |     35337 |      4563 |     39900 | 
-------------|-----------|-----------|-----------|

 

For 'Default'(credit in default?) variable, since they only have 3 clients with 'Yes' for deposit, it is literally hard to use for our modelling for analysis even if we do the Oversampling. So, I decided to drop this variable.

# Dropping the variable 'default'
bank_final = bank_final %>% 
  select(-default)

5) Housing

housing_y <- sqldf(
"select housing, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select housing, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

housing_y

  housing total deposit_yes deposit_no yes_ratio no_ratio
1     yes 20944        2468      18476     11.78    88.22
2 unknown   964         107        857     11.10    88.90
3      no 17992        1988      16004     11.05    88.95

we will just drop the 'unknown' level of housing variable since it doesn't give much special information.

# Dropping 'unknown' level from the variable 'housing'
bank_final = bank_final %>% filter(housing != "unknown")
bank_final$housing <- factor(bank_final$housing)

housing_v <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, housing), fill = y)) + mosaic_theme +
  xlab("housing loan") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set4")

ggplotly(housing_v)

6) Loan

bank_final$loan <- factor(bank_final$loan)
loan_y <- sqldf(
"select loan, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select loan, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

loan_y

  loan total deposit_yes deposit_no yes_ratio no_ratio
1   no 32882        3781      29101     11.50    88.50
2  yes  6054         675       5379     11.15    88.85

loan_v <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, loan), fill = y)) + mosaic_theme +
  xlab("Loan") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set2")

ggplotly(loan_v)

7) Contact (marketing related variable)

contact_y <- sqldf(
"select contact, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select contact, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

contact_y

    contact total deposit_yes deposit_no yes_ratio no_ratio
1  cellular 24958        3711      21247     14.87    85.13
2 telephone 13978         745      13233      5.33    94.67

contact_v <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, contact), fill = y)) + mosaic_theme +
  xlab("Contact") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set3")

ggplotly(contact_v)

8) Month

month_y <- sqldf(
"select month, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select month, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

month_y

   month total deposit_yes deposit_no yes_ratio no_ratio
1    mar   521         268        253     51.44    48.56
2    dec   174          85         89     48.85    51.15
3    sep   545         244        301     44.77    55.23
4    oct   686         302        384     44.02    55.98
5    apr  2549         519       2030     20.36    79.64
6    jun  4851         534       4317     11.01    88.99
7    aug  5829         622       5207     10.67    89.33
8    nov  4006         405       3601     10.11    89.89
9    jul  6672         618       6054      9.26    90.74
10   may 13103         859      12244      6.56    93.44

bank_final$month <- factor(bank_final$month, levels=c("jan", "feb", "mar", "apr", "may", "jun", "jul", "aug", "sep", "oct", "nov", "dec"))

month_vis <- ggplot(bank_final, aes(month, fill=y)) + geom_bar(position="stack") + scale_fill_brewer(palette="Set2") + ylab("Deposit(yes/no)") + ggtitle("Distribution of Client and Deposit by Last contact Month")

ggplotly(month_vis)

month_y$month <- factor(month_y$month, levels = month_y$month[order(-month_y$yes_ratio)])

month_vis2 <- ggplot(month_y, aes(x=month, y=yes_ratio)) +
  geom_bar(width=0.5, stat = "identity", fill="#fb8d61") +
  labs(title="Deposit(yes) ratio by Last Contact Month") +
  theme(axis.text.x = element_text(angle = 90))

ggplotly(month_vis2)

9) Day of Week

weekday_y <- sqldf(
"select day_of_week, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select day_of_week, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

weekday_y

  day_of_week total deposit_yes deposit_no yes_ratio no_ratio
1         thu  8106         997       7109     12.30    87.70
2         tue  7645         909       6736     11.89    88.11
3         wed  7714         917       6797     11.89    88.11
4         fri  7393         815       6578     11.02    88.98
5         mon  8078         818       7260     10.13    89.87

bank_final$day_of_week <- factor(bank_final$day_of_week, levels=c("mon", "tue", "wed", "thu", "fri"))

weekday_vis <- ggplot(bank_final, aes(day_of_week, fill=y)) + geom_bar(position="stack") + ylab("Deposit(yes/no)") + ggtitle("Distribution of Client and Deposit by Day of Week")

ggplotly(weekday_vis)

weekday_y$day_of_week <- factor(weekday_y$day_of_week, levels = weekday_y$day_of_week[order(-weekday_y$yes_ratio)])

weekday_vis2 <- ggplot(weekday_y, aes(x=day_of_week, y=yes_ratio)) +
  geom_bar(width=0.5, stat = "identity", fill="#2ebfc4") +
  labs(title="Deposit(yes) ratio by Day of Week") +
  theme(axis.text.x = element_text(angle = 90))

ggplotly(weekday_vis2)

The result shows that there are certain week days that have more positive response on Deposit subscription such as Thursday, Tuesday, Wednesday. However, in overall, there are not much prominent gap of Deposit (yes/no) between each week day.

10) Previous

crosstable_function(bank_final, "previous", "y")

 
   Cell Contents
|-------------------------|
|                       N |
|           N / Row Total |
|-------------------------|

 
Total Observations in Table:  38936 

 
             | y 
    previous |        no |       yes | Row Total | 
-------------|-----------|-----------|-----------|
           0 |     30494 |      3021 |     33515 | 
             |     0.910 |     0.090 |     0.861 | 
-------------|-----------|-----------|-----------|
           1 |      3986 |      1435 |      5421 | 
             |     0.735 |     0.265 |     0.139 | 
-------------|-----------|-----------|-----------|
Column Total |     34480 |      4456 |     38936 | 
-------------|-----------|-----------|-----------|

 

previous_vis <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, previous), fill = y)) + mosaic_theme +
  xlab("previous contact(yes/no)") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set3")

ggplotly(previous_vis)

The results shows that the clients who have got contacted previously before this campaign are more likely to subscribe Deposit(yes). So we can say that re-reaching to the clients can be regarded as quite important in this telemarketing campaign.

10) Poutcome

poutcome_y <- sqldf(
"select poutcome, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select poutcome, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

poutcome_y

     poutcome total deposit_yes deposit_no yes_ratio no_ratio
1     success  1320         863        457     65.38    34.62
2     failure  4101         572       3529     13.95    86.05
3 nonexistent 33515        3021      30494      9.01    90.99

poutcome_vis <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, poutcome), fill = y)) + mosaic_theme +
  xlab("previous campaign outcome") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set2")

ggplotly(poutcome_vis)

Based on the above results, we can conclude that the clients who had contacted for 'previous campaign' at least once have more chance to positively respond and subscribe 'Deposit'. Even if the previous outcome was failure, it still shows higher deposit(yes) ratio than the clients who have never been contacted for marketing.

Numerical Variables

For numerical variable, we will not check every each of them, but rather focus on some variables with important insights.

1) Age

age_y <- sqldf(
"select age, total, deposit_yes, deposit_no, round(100.*deposit_yes/total, 2) as yes_ratio, round(100.*deposit_no/total, 2) as no_ratio
from(
select age, count(*) as total, sum(case when y = 'yes' then 1 else 0 end) as deposit_yes, sum(case when y = 'no' then 1 else 0 end) as deposit_no 
from bank_final
group by 1
) order by yes_ratio DESC")

age_y

   age total deposit_yes deposit_no yes_ratio no_ratio
1   87     1           1          0    100.00     0.00
2   89     2           2          0    100.00     0.00
3   98     2           2          0    100.00     0.00
4   92     4           3          1     75.00    25.00
5   86     7           5          2     71.43    28.57
6   77    19          12          7     63.16    36.84
7   82    16          10          6     62.50    37.50
8   80    30          17         13     56.67    43.33
9   79    13           7          6     53.85    46.15
10  76    32          17         15     53.13    46.88
11  78    25          13         12     52.00    48.00
12  66    49          25         24     51.02    48.98
 [ reached 'max' / getOption("max.print") -- omitted 66 rows ]

boxplot(bank_final$age, main="Age plot", yaxt="n", xlab="age", horizontal=TRUE)

ggplot(bank_final,aes(x=bank_final$age,fill=bank_final$y)) + geom_histogram(binwidth=1) +
  labs(y= "Count", x="Age", title = "Age")

Based on the plots above, we can think of 2 marketing campaign strategies. 1) targetting mid-young~mid aged people like 30s-40s.; 2) Think of the strategies to target aged clients or very young clients like 20s. Especially, I think it's good to target young clients in 20s because the Deposit distribution shows that clients from 25 y.o. are starting to increase in subscribing Deposit. And retaining young clients are beneficial to the bank since they can turn into the long-term loyal clients once the rapport is built.

Anyway, I will tranform this Age variable(numeric) into categorical variable with grouping age range as 'Low/Mid/High'

bank_final = bank_final %>% 
  mutate(age = if_else(age > 60, "high", if_else(age > 30, "mid", "low")))
bank_final$age <- factor(bank_final$age)

Histogram plot of all numeric variables in overall

bank_final %>%
  keep(is.numeric) %>% 
  gather() %>% 
  ggplot(aes(value)) +
    facet_wrap(~ key, scales = "free") +
    geom_histogram()

Based on what we see in this histogram plot, we can check the variable campaign and pdays in detail since pdays somehow shows outlier distribution.

2) Campaign

campaign_vis <- bank_final %>% 
  ggplot() +
  geom_mosaic(aes(x = product(y, campaign), fill = y)) + mosaic_theme +
  xlab("number of contacts during this campaign") + ylab("Deposit Subscription") + scale_fill_brewer(palette="Set2")

ggplotly(campaign_vis)

3) Pdays

ggplot(data = bank_final, aes(x=bank_final$pdays))+
  geom_histogram(bins=30)+
  labs(x="Number of days since last contact", y="Count")

If you see the pdays distribution, it is absolutely showing the distribution that is hard to use for our analysis since most of the values are 999 which means they have not previously contacted. This happened maybe because we dropped some variables and unknown levels in the previous steps while doing EDA. Anyway, we already have very similar variable called 'previous' which shows if the client was contacted last time(before this campaign) or not. So, we can just drop this pdays variable.

bank_final = bank_final %>% 
  select(-pdays)

Choose appropriate Cut/Threshold

Before getting into the model evaluation part, let's think of what metrics are proper for us to check the model performance in this telemarketing business problem. For this situation, the most important priority is 'if we can precisely find clients who are willing to subscribe to a Deposit product (TP=true positive)'. And at the same time, we also need to consider 'if we didn't miss potential clients who may actually subscribe for Deposit but classified as they will not' (FN=False Negative). Considering this point, I think F-score is an ideal metric we can use in here in that it is typically used to measure how accurate the 'classification' is made. When F-score high, the Precision and Recall is also high. Therefore, I will more focus on the F score(f1 score) which consider both of Precision and Recall than Accuracy.

logistic_train_score = predict(logistic, newdata = bank_train_smote, type = "response")
logistic_test_score = predict(logistic, newdata = bank_test, type = "response")

measure_train = fun_gg_cutoff(logistic_train_score, bank_train_smote$y, 
                              "acc", "f")
measure_train +
  geom_vline(xintercept = c(0.4, 0.5), 
             linetype = "dashed")

We can see the best cut(threshold) for both F score and Accuracy in training set prediction is 0.4.

Then, let's check real test set threshold.

logistic_train_cut = 0.4
measure_test = fun_gg_cutoff(logistic_test_score, bank_test$y, "acc", "f")
measure_test + geom_vline(xintercept = c(0.5, logistic_train_cut), linetype = "dashed")

Considering the amount of Tradeoff between Accuracy and F-score, it's better to choose our threshold as '0.68' for test set prediction. (because it shows the highest F1 score with quite high accuracy too.)

Confusion Matrix & Model Evaluation Metrics

logistic_test_class = fun_cut_predict(logistic_test_score, 0.68)
# matrix
logistic_test_confm = confusionMatrix(logistic_test_class, bank_test$y, 
                                      positive = "1",
                                      mode = "everything")
logistic_test_confm

Confusion Matrix and Statistics

          Reference
Prediction     0     1
         0 10364   755
         1   811   697
                                          
               Accuracy : 0.876           
                 95% CI : (0.8701, 0.8817)
    No Information Rate : 0.885           
    P-Value [Acc > NIR] : 0.9992          
                                          
                  Kappa : 0.4007          
                                          
 Mcnemar's Test P-Value : 0.1646          
                                          
            Sensitivity : 0.4800          
            Specificity : 0.9274          
         Pos Pred Value : 0.4622          
         Neg Pred Value : 0.9321          
              Precision : 0.4622          
                 Recall : 0.4800          
                     F1 : 0.4709          
             Prevalence : 0.1150          
         Detection Rate : 0.0552          
   Detection Prevalence : 0.1194          
      Balanced Accuracy : 0.7037          
                                          
       'Positive' Class : 1               
                                          

Confusion Matrix & Model Evaluation Metrics

logistic2_test_class = fun_cut_predict(logistic2_test_score, 0.67)
# matrix
logistic2_test_confm = confusionMatrix(logistic2_test_class, bank_test$y, 
                                      positive = "1",
                                      mode = "everything")
logistic2_test_confm

Confusion Matrix and Statistics

          Reference
Prediction     0     1
         0 10305   733
         1   870   719
                                          
               Accuracy : 0.873           
                 95% CI : (0.8671, 0.8788)
    No Information Rate : 0.885           
    P-Value [Acc > NIR] : 0.9999847       
                                          
                  Kappa : 0.4009          
                                          
 Mcnemar's Test P-Value : 0.0006817       
                                          
            Sensitivity : 0.49518         
            Specificity : 0.92215         
         Pos Pred Value : 0.45249         
         Neg Pred Value : 0.93359         
              Precision : 0.45249         
                 Recall : 0.49518         
                     F1 : 0.47287         
             Prevalence : 0.11499         
         Detection Rate : 0.05694         
   Detection Prevalence : 0.12584         
      Balanced Accuracy : 0.70866         
                                          
       'Positive' Class : 1               
                                          

Comparing to the first full LR model, we can see that most of the metrics didn't change that much. Metrics like Sensitivity, F1 Score, Recall have increased a bit than the first full model.

Choose appropriate Cut/Threshold

Trainset

measure_train = fun_gg_cutoff(tree_train_score, bank_train_smote$y,"acc", "f")
measure_train + geom_vline(xintercept = c(0.4, 0.5), linetype = "dashed")

You can see that the best cut for F-score is around 0.4 for training set' prediction.

Testset

tree_train_cut = 0.4
measure_test = fun_gg_cutoff(tree_test_score, bank_test$y, "acc", "f")
measure_test + geom_vline(xintercept = c(tree_train_cut, 0.5), linetype = "dashed")

In test set' prediction, best threshold figure for F-score is 0.6. Let's check the confusion matrix and metrics of this tree model.

Confusion Matrix & Model Evaluation Metrics

tree_test_class = fun_cut_predict(tree_test_score, 0.6)
tree_test_confm = confusionMatrix(tree_test_class, bank_test$y, positive = "1", mode = "everything")
tree_test_confm

Confusion Matrix and Statistics

          Reference
Prediction     0     1
         0 10069   587
         1  1106   865
                                          
               Accuracy : 0.8659          
                 95% CI : (0.8599, 0.8718)
    No Information Rate : 0.885           
    P-Value [Acc > NIR] : 1               
                                          
                  Kappa : 0.4299          
                                          
 Mcnemar's Test P-Value : <2e-16          
                                          
            Sensitivity : 0.5957          
            Specificity : 0.9010          
         Pos Pred Value : 0.4389          
         Neg Pred Value : 0.9449          
              Precision : 0.4389          
                 Recall : 0.5957          
                     F1 : 0.5054          
             Prevalence : 0.1150          
         Detection Rate : 0.0685          
   Detection Prevalence : 0.1561          
      Balanced Accuracy : 0.7484          
                                          
       'Positive' Class : 1               
                                          

Comparing this Tree model to the last LR2 model, this tree model shows some better metrics in F1 score, Recall, and Sensitivity. Let's compare this model's performance with other models in the next step "Model Evaluation"

Choose appropriate Cut/Threshold

Trainset

measure_train2 = fun_gg_cutoff(tree2_train_score, bank_train_smote$y,"acc", "f")
measure_train2 + geom_vline(xintercept = c(0.4, 0.5), linetype = "dashed")

You can see that the best cut for F-score is around 0.4 for training set' prediction.

Testset

tree2_train_cut = 0.4
measure_test2 = fun_gg_cutoff(tree2_test_score, bank_test$y, "acc", "f")
measure_test2 + geom_vline(xintercept = c(tree2_train_cut, 0.5), linetype = "dashed")

In test set' prediction, best threshold figure for F-score is 0.7. Let's check the confusion matrix and metrics of this tree model.

Confusion Matrix & Model Evaluation Metrics

tree2_test_class = fun_cut_predict(tree2_test_score, 0.7)
tree2_test_confm = confusionMatrix(tree2_test_class, bank_test$y, positive = "1", mode = "everything")
tree2_test_confm

Confusion Matrix and Statistics

          Reference
Prediction     0     1
         0 10314   666
         1   861   786
                                          
               Accuracy : 0.8791          
                 95% CI : (0.8733, 0.8847)
    No Information Rate : 0.885           
    P-Value [Acc > NIR] : 0.9819          
                                          
                  Kappa : 0.4386          
                                          
 Mcnemar's Test P-Value : 6.885e-07       
                                          
            Sensitivity : 0.54132         
            Specificity : 0.92295         
         Pos Pred Value : 0.47723         
         Neg Pred Value : 0.93934         
              Precision : 0.47723         
                 Recall : 0.54132         
                     F1 : 0.50726         
             Prevalence : 0.11499         
         Detection Rate : 0.06225         
   Detection Prevalence : 0.13043         
      Balanced Accuracy : 0.73214         
                                          
       'Positive' Class : 1               
                                          

Comparing to the previous DT1 Model with full variable, this one shows only better metrics in Accuracy, Sensitivity, Specificity, Precision and F1 score. However, in overall, nothing much severe gap between these two models.